home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48hor2 / suite3d.src < prev    next >
Text File  |  1992-01-11  |  14KB  |  622 lines
  1. %%HP: T(3)A(R)F(.);
  2. @ SUITE3D by Charles Patton
  3. DIR
  4.  
  5.   VPAR
  6.   DIR
  7.     Xleft
  8.       0
  9.     Xright
  10.       3
  11.     Ynear
  12.       0
  13.     Yfar
  14.       3
  15.     Zlow
  16.       -1
  17.     Zhigh
  18.       2.5
  19.     XXleft
  20.       0
  21.     XXright
  22.       3
  23.     YYlow
  24.       0
  25.     YYhigh
  26.       3
  27.     Xe
  28.       2.5
  29.     Ye
  30.       -1.5
  31.     Ze
  32.       2
  33.     Nx
  34.       13
  35.     Ny
  36.       8
  37.     Hidden
  38.       0
  39.   END
  40.  
  41.   SlopeField
  42.     \<< {VPAR Nx} RCL
  43.         {VPAR Ny} RCL
  44.         {VPAR Xleft} RCL {VPAR Xright} RCL DUP2  XRNG
  45.         {VPAR Ynear} RCL {VPAR Yfar} RCL DUP2 YRNG
  46.         EQ
  47.         0 0 0 0 0 0 0
  48.           \-> numx numy left right bot top der hstp vstp hofs vofs x y d
  49.       \<< ERASE {# 0d # 0d } PVIEW
  50.           right left - numx / 'hstp' STO
  51.             top bot - numy / 'vstp' STO
  52.             hstp .4 * 'hofs' STO
  53.             vstp .4 * 'vofs' STO
  54.             bot vstp 2 / + top
  55.         FOR y
  56.               y 'Y' STO
  57.               left hstp 2 / +
  58.               right
  59.           FOR x
  60.                 x 'X' STO
  61.                 der \->NUM  'd' STO
  62.                 'IFTE(ABS(d*hofs)>vofs,vofs/d+i*vofs,hofs+i*hofs*d)' \->NUM
  63.                 x y R\->C DUP2 + 3 ROLLD SWAP - line
  64.                 hstp
  65.           STEP
  66.             vstp
  67.         STEP
  68.       \>>
  69.       { X Y } PURGE { } PVIEW
  70.     \>>
  71.  
  72.   psContour
  73.     \<<         EQ
  74.       \<< \-> dx dy 'IFTE(dy==0,MAXR,-dx/dy)' \>>
  75.       \-> eq slp
  76.       \<<
  77.         IFERR eq X \.d
  78.                 eq Y \.d
  79.                 2 \->LIST
  80.                 'slp' APPLY
  81.                 { X Y } SHOW STEQ
  82.                 SlopeField
  83.         THEN eq STEQ ERRM DOERR
  84.         END eq STEQ
  85.       \>>
  86.     \>>
  87.  
  88.   YView
  89.     \<< SetWindow 0
  90.       \<< \-> K
  91.         \<<
  92.           CASE
  93.                    K TYPE DUP 0 ==
  94.             THEN
  95.                    DROP X K R\->C
  96.                      X -50 R\->C
  97.                      DUP2 LINE TLINE
  98.                      K
  99.             END
  100.                    1 ==
  101.             THEN K
  102.             END
  103.                   K EVAL 1 \->LIST
  104.                     'PRASE' APPLY
  105.           END
  106.         \>>
  107.       \>> \-> Xleft Xright Ynear Yfar Xe Ye Ze Nx Ny  prase u hline
  108.       \<< 'EQ' RCL
  109.           'u' \-> eq u
  110.         \<< eq { X '(X-Xe)*u+Xe' Y 'u+Ye' } |
  111.               Ze - 'u' / Ze +
  112.               { X u } SHOW
  113.               COLCT
  114.           IF prase
  115.           THEN { & 'hline(&)' } \|vMATCH DROP
  116.           END
  117.           IFERR
  118.                'EQ' STO 'X' INDEP
  119.                ERASE
  120.                Ynear Yfar - 8 /
  121.                \-> stp
  122.             \<< Yfar Ye -
  123.                   Ynear Ye -
  124.               FOR u
  125.                     draw
  126.                       IF KEY
  127.                       THEN DROP
  128.                       "outa here" DOERR
  129.                       END
  130.                       stp
  131.               STEP
  132.             \>>
  133.           THEN eq STEQ ERRM DOERR
  134.           ELSE eq STEQ
  135.           END
  136.             { } PVIEW
  137.         \>>
  138.       \>>
  139.     \>>
  140.  
  141.  
  142.   WIREFRAME
  143.     \<<  SetWindow 0 0 0 0
  144.           \->  Xmin Xmax Ynear Yfar Xe Ye Ze numx numy prase u v bd1 bd2
  145.       \<< 'u' 'v' \-> u v
  146.         \<< EQ { X v Y 'u+Ye' } |
  147.               Ze - 'u' / Ze +
  148.               { v u } SHOW COLCT ERASE
  149.               { # 0d # 0d } PVIEW
  150.               Ynear Yfar - numy /
  151.               Xmax Xmin - numx /
  152.               \-> eq stpu stpx
  153.           \<< Yfar Ye -
  154.                 Ynear Ye -
  155.             FOR u
  156.                   0 'bd1' STO
  157.                     Xmin 'v' STO
  158.                     0 numx
  159.               START
  160.                   v Xe - u / Xe +
  161.                     eq \->NUM R\->C
  162.                     IF bd1
  163.                     THEN DUP2 line
  164.                     ELSE 1 'bd1' STO
  165.                     END
  166.                     IF bd2
  167.                     THEN numx 2 + ROLL OVER line
  168.                     END
  169.                     stpx 'v' STO+
  170.               NEXT
  171.                 1 'bd2' STO
  172.                 stpu
  173.             STEP
  174.               numx 1 + DROPN
  175.           \>> { } PVIEW
  176.         \>>
  177.       \>>
  178.     \>>
  179.  
  180.   ShapeToShade
  181.     \<< {VPAR Xleft} RCL
  182.         {VPAR Xright} RCL
  183.         {VPAR Ynear} RCL
  184.         {VPAR Yfar} RCL
  185.           0 0 0 \-> xmin xmax ymin ymax x y eq
  186.       \<< xmax xmin - 32 /
  187.           ymin ymax - 15.001 /
  188.             'x' 'y'
  189.             \-> xstp ystp x y
  190.         \<< EQ DUP
  191.               X \.d .4 - 2 ^ SWAP
  192.               Y \.d .4 + 2 ^ +
  193.               1 + -.35 ^
  194.               { X x Y y } | COLCT
  195.               'eq' STO
  196.               ERASE {# 0d # 0d } PVIEW
  197.               # 0d
  198.               ymax ymin
  199.           FOR y
  200.                 # 0d
  201.                 xmin xmax
  202.             FOR x
  203.                   DUP2 SWAP 2 \->LIST
  204.                     PICT SWAP
  205.                     eq \->NUM
  206.               IF
  207.                   DUP TYPE 0 \=/
  208.               THEN
  209.                   DROP 1
  210.               END
  211.                     tile
  212.                     15.99 * IP
  213.                     DPAR SWAP 16 - NEG GET
  214.                     REPL
  215.                     4 +
  216.                     xstp
  217.             STEP
  218.               DROP
  219.               4 +
  220.               ystp
  221.           STEP DROP { } PVIEW
  222.         \>>
  223.       \>>
  224.     \>>
  225.  
  226.   Movie
  227.     \<< {VPAR Xleft} RCL {VPAR Xright} RCL XRNG
  228.         {VPAR Zlow} RCL {VPAR Zhigh} RCL YRNG
  229.         {VPAR Ynear} RCL {VPAR Yfar} RCL
  230.         {VPAR Ny} RCL
  231.         EQ
  232.           0 0
  233.           \->  ynear yfar numy eq ystp y
  234.       \<< 'y' 'y' STO
  235.           eq { X Y } SHOW
  236.             { Y y } |
  237.             ynear yfar - numy / 'ystp' STO
  238.         IFERR STEQ
  239.                'X' INDEP
  240.                FUNCTION
  241.                0 yfar ynear
  242.           FOR y
  243.                 ERASE draw
  244.                 y PICT RCL ROT 2 +
  245.             IF KEY
  246.             THEN
  247.                 DROP "outa here"
  248.                 DOERR
  249.             END
  250.               ystp
  251.           STEP
  252.         THEN
  253.                eq STEQ
  254.                ERRM DOERR
  255.         END
  256.           eq STEQ
  257.       \>> uSMOV
  258.     \>>
  259.  
  260.   uSMOV
  261.     \<< \-> n
  262.       \<< { # 0d # 0d } PVIEW
  263.         DO n ROLL
  264.              n ROLL
  265.              DUP PICT {# 0d # 0d } ROT REPL
  266.         UNTIL KEY
  267.         END DROP n
  268.       \>>
  269.     \>>
  270.  
  271.   SSTMovie
  272.     \<<
  273.       DO
  274.         \-> n
  275.         \<< n ROLL n ROLL DUP PICT
  276.               {# 0d # 0d } ROT REPL n
  277.               { # 0d # 0d } PVIEW
  278.         \>>
  279.       UNTIL 0 WAIT
  280.             51.1 ==
  281.       END
  282.     \>>
  283.  
  284.   GRIDMAP
  285.   \<< EQ PPAR VPAR Xleft Xright Ynear Yfar
  286.         XXright XXleft YYlow YYhigh Nx Ny
  287.       UPDIR 
  288.       \-> eq pp X1 X2 Y1 Y2 xr1 xr2 yr1 yr2 NX NY
  289.     \<< X2 X1 - 
  290.         Y2 Y1 -
  291.         \-> DX DY
  292.       \<< eq { X 
  293.                'X1+DX*(1+INV(NX-1))*
  294.                (.5+(-1)^IP(NY*((1-INV(NX*NY))*TTT+.5/(NX*NY)))*
  295.                (-.5+FP(NY*((1-INV(NX*NY))*TTT+.5/(NX*NY)))))-
  296.                .5*(DX/(NX-1))' 
  297.                Y 
  298.                'Y1+DY/(NY-1)*IP(NY*((1-INV(NX*NY))*TTT+.5/(NX*NY)))'
  299.               } | { TTT } SHOW 
  300.            eq { X 
  301.                'X1+DX/(NX-1)*IP(NX*((1-INV(NY*NX))*TTT+.5/(NY*NX)))' 
  302.                Y 
  303.                'Y1+DY*(1+INV(NY-1))*
  304.                (.5+(-1)^IP(NX*((1-INV(NY*NX))*TTT+.5/(NY*NX)))*
  305.                (-.5+FP(NX*((1-INV(NY*NX))*TTT+.5/(NY*NX)))))-
  306.                .5*(DY/(NY-1))'
  307.                } | { TTT } SHOW 
  308.           SWAP
  309.         IFERR { TTT 0 1 } INDEP
  310.               PARAMETRIC 
  311.               xr1 xr2 XRNG 
  312.               yr1 yr2 YRNG
  313.               NX NY * 1 - INV RES
  314.               STEQ 
  315.               ERASE pardraw
  316.               STEQ pardraw 
  317.               { } PVIEW 
  318.               pp 'PPAR' STO eq STEQ
  319.         THEN eq STEQ pp 'PPAR' STO 
  320.               ERRM DOERR
  321.         END
  322.       \>>
  323.     \>>
  324.   \>>
  325.  
  326.   DPAR {
  327. GROB 4 4 00400000
  328. GROB 4 4 00402000
  329. GROB 4 4 90000080
  330. GROB 4 4 40104010
  331. GROB 4 4 20802090
  332. GROB 4 4 8050A010
  333. GROB 4 4 50A05080
  334. GROB 4 4 A050A050
  335. GROB 4 4 50A050A0
  336. GROB 4 4 A050A070
  337. GROB 4 4 70A050E0
  338. GROB 4 4 D070D060
  339. GROB 4 4 B0E0B0E0
  340. GROB 4 4 70D0F0B0
  341. GROB 4 4 F0B0D0F0
  342. GROB 4 4 F0B0F0F0 }
  343.  
  344.   EQ
  345.     '2*(2-Y)*EXP(-((X-.5)^2+(Y-1.2)^2))+Y*EXP(-2*((X-2)^2+(Y-2)^2))'
  346.  
  347.   PPAR
  348.     { (-2,0) (2,5) X # 8d (0,0) FUNCTION Y }
  349.  
  350.   SetWindow
  351.     \<< PATH
  352.         VPAR
  353.         Xleft Xright Ynear Yfar Zlow Zhigh Xe Ye Ze Nx Ny Hidden 0
  354.        \-> Xleft Xright Ynear Yfar Zlow Zhigh Xe Ye Ze Nx Ny Hidden Ue
  355.        \<< EVAL
  356.            \<< \-> u y '(u-Ue)/(y-Ye)+Ue' SWAP OVER MAX ROT ROT MIN SWAP \>>
  357.            \-> proj
  358.            \<< Xe 'Ue' STO
  359.                MAXR \->NUM DUP NEG
  360.                Xleft Ynear proj EVAL
  361.                Xleft Yfar proj EVAL
  362.                Xright Ynear proj EVAL
  363.                Xright Yfar proj EVAL
  364.                XRNG
  365.                Ze 'Ue' STO
  366.                MAXR \->NUM DUP NEG
  367.                Zlow Ynear proj EVAL
  368.                Zlow Yfar proj EVAL
  369.                Zhigh Ynear proj EVAL
  370.                Zhigh Yfar proj EVAL
  371.                YRNG
  372.            \>>
  373.            Xleft Xright Ynear Yfar Xe Ye Ze Nx Ny Hidden
  374.       \>>
  375.    \>>
  376.  
  377.  
  378.   draw
  379.     DRAW
  380.  
  381.   line
  382.     LINE
  383.  
  384.   tile
  385.    \<< \>>
  386.  
  387.   pardraw
  388.     DRAW
  389.  
  390. @ Begin POSTSCRIPT Stuff @
  391.  
  392.   PSTOGGLE
  393.    \<< "PS is "
  394.      IF 'draw' RCL 'PSDRAW' SAME
  395.      THEN { DRAW } 1    GET DUP 'draw' STO
  396.           'pardraw' STO 
  397.           { LINE } 1 GET 'line'    STO
  398.           \<<  \>> 'tile' STO
  399.          "Off" +
  400.      ELSE 'PSDRAW' 'draw' STO 
  401.           'PSLINE'  'line' STO 
  402.           'PSTILE'  'tile' STO
  403.           'PSPARDRAW'  'pardraw' STO 
  404.           "On" +
  405.      END 1 DISP
  406.    \>>
  407.    
  408.   PSRESET
  409.     \<< "'PSOUT" 'PSOUT'
  410.         DO "" SWAP STO
  411.              "&" + DUP STR\-> DUP
  412.           UNTIL VTYPE -1 ==
  413.           END
  414.           DROP2 'PSOUT' 'CURRENTOUT' STO
  415.     \>>
  416.  
  417.   PSTILE
  418.     \<< DUP \->STR
  419.         " g
  420. "
  421.           + 5 PICK B\->R
  422.           DUP 4 + \->STR " " +
  423.           SWAP \->STR " " +
  424.           8 PICK # 64d SWAP - B\->R
  425.           DUP 4 - \->STR
  426.           " " + SWAP \->STR " " +
  427.           \-> X2 X1 Y1 Y2
  428.       \<< X2 + Y1 +
  429. "m
  430. "
  431.       + X2 + Y2 +
  432. "L
  433. "
  434.       + X1 + Y2 +
  435. "L
  436. "
  437.       + X1 + Y1 +
  438. "L
  439. "
  440.       + X2 + Y1 +
  441. "L
  442. f
  443. "
  444.       +
  445.       \>> PSADDTO
  446.     \>>
  447.  
  448.   PSADDTO
  449.     \<<
  450.       IF CURRENTOUT SIZE 4000 >
  451.       THEN 'CURRENTOUT' RCL \->STR
  452.            1 OVER SIZE 1 - SUB "&" + STR\->
  453.              DUP 'CURRENTOUT' STO STO
  454.       ELSE
  455.            'CURRENTOUT' RCL SWAP STO+
  456.       END
  457.     \>>
  458.  
  459.   CURRENTOUT
  460.     PSOUT
  461.  
  462.   PSCOPAIR
  463.     \<< 'PPAR(1)' EVAL DUP
  464.         'PPAR(2)' EVAL SWAP -
  465.           \-> p1 p2 o d
  466.       \<< p2 o - C\->R
  467.           d C\->R ROT SWAP / 64 *
  468.             ROT ROT / 131 *
  469.             p1 o - C\->R d C\->R
  470.             ROT SWAP / 64 *
  471.             ROT ROT / 131 *
  472.       \>> \-> y2 x2 y1 x1
  473.       \<< x1 \->STR " " +
  474.           y1 \->STR " " + +
  475.             x2 \->STR " " + +
  476.             y2 \->STR " " + +
  477.             x2 x1 - x2 + \->STR " " +
  478.             y2 y1 - y2 + \->STR " " + +
  479.       \>>
  480.     \>>
  481.  
  482.   PSDRAW
  483.     \<< PPAR OBJ\-> 4 DROPN
  484.         0 0
  485.           \-> hm vm indp rs flop \Gdx
  486.       \<<
  487.         IF rs TYPE 10 ==
  488.         THEN rs # 0d 2 \->LIST PX\->C hm - RE
  489.         ELSE
  490.           IF rs 0 ==
  491.           THEN { # 1d # 0d } PX\->C hm - RE
  492.           ELSE rs
  493.           END
  494.         END
  495.           3 / '\Gdx' STO
  496.           'EQ' RCL 'vm' STO
  497.         \<< \-> vl
  498.           \<< vl \->NUM
  499.                 indp \->NUM
  500.                 \-> vlu indv
  501.             \<<
  502.               IF flop
  503.               THEN indv \Gdx - vl indp \.d \->NUM
  504.                      \Gdx *
  505.                        vlu SWAP - R\->C
  506.                        'indp+vl*i' \->NUM PSCOPAIR
  507.                        3 ROLLD + "c
  508. "
  509.                      +
  510.                        PSADDTO
  511.               ELSE
  512.                      'indp+vl*i' \->NUM
  513.                        PSCO "m
  514. "
  515.                    +
  516.                        indv \Gdx +
  517.                        vl indp \.d \->NUM
  518.                        \Gdx * vlu + R\->C PSCO +
  519.                        1 'flop' STO
  520.               END
  521.                 vlu
  522.             \>>
  523.           \>>
  524.         \>> 'hm' STO
  525.         IFERR vm {& 'hm(QUOTE(&))' } \|vMATCH DROP STEQ
  526.                 DRAW vm STEQ
  527.         THEN vm STEQ ERRM DOERR
  528.         END "S
  529. "
  530.         PSADDTO
  531.       \>>
  532.     \>>
  533.  
  534.   PSPARDRAW
  535.     \<< 'PPAR(3)' EVAL OBJ\-> DROP 'PPAR(4)' EVAL 0 0
  536.         \->indp hm vm rs flop \Gdx
  537.       \<<
  538.         IF rs 0 ==
  539.         THEN # 1d 'rs' STO
  540.         END
  541.         IF rs TYPE 10 ==
  542.         THEN rs B\->R 131 / vm hm - *
  543.         ELSE rs
  544.         END 3 / '\Gdx' STO 'EQ' RCL 'vm' STO
  545.         \<< \-> vl
  546.           \<< vl \->NUM indp \->NUM
  547.               \-> vlu indv
  548.             \<<
  549.               IF flop
  550.               THEN vl indp \.d \->NUM \Gdx * vlu SWAP - (0,0) + vlu (0,0) +
  551.                    PSCOPAIR 3 ROLLD +
  552. "c
  553. "                  + PSADDTO
  554.               ELSE vlu (0,0) + PSCO
  555. "m
  556. "
  557.                    + vl indp \.d \->NUM \Gdx * vlu + (0,0) + PSCO +
  558.                     1 'flop' STO
  559.               END
  560.               vlu
  561.             \>>
  562.           \>>
  563.         \>> 'hm' STO
  564.         IFERR vm { & 'hm(QUOTE(&))' } \|vMATCH DROP STEQ
  565.               DRAW vm STEQ
  566.         THEN vm STEQ ERRM DOERR
  567.         END
  568. "S
  569. "
  570.         PSADDTO
  571.       \>>
  572.     \>>
  573.  
  574.   PSCO
  575.     \<< 'PPAR(1)' EVAL - C\->R
  576.         'PPAR(2)-PPAR(1)' EVAL C\->R
  577.           ROT SWAP / 64 *
  578.           ROT ROT / 131 * \->STR
  579.           " " + SWAP \->STR
  580.           " " + +
  581.     \>>
  582.  
  583.   PSLINE
  584.     \<< \-> C1 C2
  585.       \<< C1 PSCO
  586. "m
  587. "
  588.           + C2 PSCO +
  589. "l
  590. S
  591. "
  592.           + PSADDTO
  593.             C1 C2 LINE
  594.       \>>
  595.     \>>
  596.  
  597.   derMOD
  598.     \<< \-> K L DK DL 'DK'    \>>
  599.   derIP
  600.     \<< \-> K DK '0'   \>>
  601.   derIM
  602.     \<< \-> K DK 'IM(DK)'   \>>
  603.   derRE
  604.     \<< \-> K DK 'RE(DK)'   \>>
  605.  
  606.   PSOUT
  607.    ""
  608.   PSOUT&
  609.    ""
  610.   PSOUT&&
  611.    ""
  612.   PSOUT&&&
  613.    ""
  614.   PSOUT&&&&
  615.    ""
  616.   PSOUT&&&&&
  617.    ""
  618.   PSOUT&&&&&&
  619.    ""
  620. END
  621.  
  622.